Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/newtable.fr_/newtable.fr

Text File | 1995-07-04 | 13KB | 439 lines

VERSION 4.00
Begin VB.Form frmMain
   BackColor       =   &H00C0C0C0&
   Caption         =   "Table Creator"
   ClientHeight    =   4320
   ClientLeft      =   2100
   ClientTop       =   1500
   ClientWidth     =   6330
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   4725
   Left            =   2040
   LinkTopic       =   "Form1"
   ScaleHeight     =   4320
   ScaleWidth      =   6330
   Top             =   1155
   Width           =   6450
   Begin VB.CommandButton cmdListTables
      Caption         =   "&List Tables"
      Height          =   615
      Left            =   4620
      TabIndex        =   10
      Top             =   1860
      Width           =   1395
   End
   Begin VB.CommandButton cmdRemoveField
      Caption         =   "&Remove Field"
      Height          =   615
      Left            =   4620
      TabIndex        =   9
      Top             =   1140
      Width           =   1395
   End
   Begin VB.ComboBox cboFieldTypes
      Height          =   300
      Left            =   1800
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   1260
      Width           =   2535
   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "Close"
      Height          =   615
      Left            =   4620
      TabIndex        =   12
      Top             =   3300
      Width           =   1395
   End
   Begin VB.CommandButton cmdCreateTable
      Caption         =   "&Create Table"
      Height          =   615
      Left            =   4620
      TabIndex        =   11
      Top             =   2580
      Width           =   1395
   End
   Begin VB.CommandButton cmdAddField
      Caption         =   "&Add Field"
      Default         =   -1  'True
      Height          =   615
      Left            =   4620
      TabIndex        =   8
      Top             =   420
      Width           =   1395
   End
   Begin VB.ListBox lstFields
      Height          =   1815
      Left            =   1380
      TabIndex        =   7
      Top             =   1980
      Width           =   2955
   End
   Begin VB.TextBox txtFieldName
      Height          =   285
      Left            =   1800
      TabIndex        =   3
      Top             =   840
      Width           =   2535
   End
   Begin VB.TextBox txtTableName
      Height          =   285
      Left            =   1800
      TabIndex        =   1
      Top             =   420
      Width           =   2535
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Field Li&st:"
      Height          =   195
      Left            =   300
      TabIndex        =   6
      Top             =   1980
      Width           =   840
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Field T&ype:"
      Height          =   195
      Left            =   300
      TabIndex        =   4
      Top             =   1320
      Width           =   960
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Field Name:"
      Height          =   195
      Left            =   300
      TabIndex        =   2
      Top             =   900
      Width           =   1020
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Table Name:"
      Height          =   195
      Left            =   300
      TabIndex        =   0
      Top             =   480
      Width           =   1095
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private IllegalCharacters(1 To 5) As String * 1

Const FIELDNAME = 1
Const TABLENAME = 2

Private Sub Form_Load()

    ' Initialize the combo box and array of illegal characters.
    FillTypeList
    FillIllegalCharacterArray

End Sub

Sub FillTypeList()

    ' Add each field type to the list.
    cboFieldTypes.AddItem "Counter"
    cboFieldTypes.AddItem "Currency"
    cboFieldTypes.AddItem "Date/Time"
    cboFieldTypes.AddItem "Memo"
    cboFieldTypes.AddItem "Number: Byte"
    cboFieldTypes.AddItem "Number: Integer"
    cboFieldTypes.AddItem "Number: Long"
    cboFieldTypes.AddItem "Number: Single"
    cboFieldTypes.AddItem "Number: Double"
    cboFieldTypes.AddItem "OLE Object"
    cboFieldTypes.AddItem "Text"
    cboFieldTypes.AddItem "Yes/No"

End Sub

Sub FillIllegalCharacterArray()

    ' Fill the array with the list of characters that are illegal in
    ' table names and field names.
    IllegalCharacters(1) = "["
    IllegalCharacters(2) = "]"
    IllegalCharacters(3) = "."
    IllegalCharacters(4) = "!"
    IllegalCharacters(5) = "`"

End Sub

Private Sub cmdListTables_Click()

    ' Display the table list form modally.
    frmTableList.Show 1

End Sub

Private Sub cmdAddField_Click()
    Dim fieldType As String

    ' Make sure the name entered in txtFieldName meets all the
    ' requirements for a legal field name.
    If LegalName(FIELDNAME) Then

        ' Make sure that the user has selected a field type.
        If cboFieldTypes.ListIndex > -1 Then

            ' Convert the field type selected by the user to the name
            ' required by the CREATE TABLE syntax.
            Select Case cboFieldTypes.TEXT
                Case "Counter"
                    fieldType = "COUNTER"
                Case "Currency"
                    fieldType = "CURRENCY"
                Case "Date/Time"
                    fieldType = "DATETIME"
                Case "Memo"
                    fieldType = "LONGTEXT"
                Case "Number: Byte"
                    fieldType = "BYTE"
                Case "Number: Integer"
                    fieldType = "SHORT"
                Case "Number: Long"
                    fieldType = "LONG"
                Case "Number: Single"
                    fieldType = "SINGLE"
                Case "Number: Double"
                    fieldType = "DOUBLE"
                Case "OLE Object"
                    fieldType = "LONGBINARY"
                Case "Text"
                    fieldType = "TEXT"
                Case "Yes/No"
                    fieldType = "BIT"
            End Select

            ' Delimit the field name by [], then add the field name and
            ' field type to the field list.
            lstFields.AddItem "[" & txtFieldName & "] " & fieldType

            ' Reinitialize the field name text box and field type list
            ' for entry of the next field.
            txtFieldName = ""
            cboFieldTypes.ListIndex = -1

        Else

            MsgBox "You must select a field type.", vbExclamation

        End If

    End If

End Sub

Function LegalName(whichName As Integer) As Boolean
    Dim i As Integer
    Dim isOK As Boolean
    Dim nm As String
    Dim db As DATABASE
    Dim dbName As String
    Dim td As TableDef

    On Error GoTo IllegalName

    ' Set the nm variable to the current contents of txtFieldName
    ' or txtTableName, depending on which name is being checked.
    If whichName = FIELDNAME Then
        nm = txtFieldName
    Else
        nm = txtTableName
    End If

    ' If the user has entered no name, generate an error.
    If Len(nm) = 0 Then Error 32767

    ' If the name has a leading space, generate an error.
    If Left$(nm, 1) = " " Then Error 32766

    ' If the name contains an illegal character, generate an error.
    For i = 1 To 5
        If InStr(nm, IllegalCharacters(i)) > 0 Then Error 32765
    Next i

    ' If the name contains an ANSI control character (ANSI codes
    ' 0 to 31), generate an error.
    For i = 0 To 31
        If InStr(nm, Chr(i)) > 0 Then Error 32764
    Next i

    ' If the name being checked is a field name and the field name
    ' has already been used, generate an error.
    If whichName = FIELDNAME Then
        For i = 0 To lstFields.ListCount - 1
            If nm = lstFields.List(i) Then Error 32763
        Next i

    ' If the name being checked is a table name and the table name
    ' already exists in DATABASE_NAME, generate an error.
    ElseIf whichName = TABLENAME Then
    ' Get the database name and open the database.
    dbName = BiblioPath()       ' BiblioPath is a function in READINI.BAS
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)
    For Each td In db.TableDefs
            If td.Name = nm Then Error 32762
        Next
    End If

    ' No error was generated, so the name must be legal.
    LegalName = True

Exit Function

IllegalName:
    Dim errorMsg As String
    Dim context As String

    ' Set the context depending on the type of name being checked.
    ' The context is used in the error messages.
    If whichName = FIELDNAME Then
        context = "field name"
    Else
        context = "table name"
    End If

    ' Build an error message based on the user-defined error that occurred.
    Select Case Err
        Case 32767
            errorMsg = "You must enter a " & context & "."
        Case 32766
            errorMsg = "The " & context & " cannot begin with a space."
        Case 32765
            errorMsg = "The " & context & " contains the illegal character "
            errorMsg = errorMsg & IllegalCharacters(i) & "."
        Case 32764
            errorMsg = "The " & context & " contains the control character "
            errorMsg = errorMsg & "with the ANSI value" & Str$(i) & "."
        Case 32763
            errorMsg = "The field name " & nm
            errorMsg = errorMsg & " already exists in the field name list."
        Case 32762
            errorMsg = "The table name " & nm
            errorMsg = errorMsg & " already exists in the database "
            errorMsg = errorMsg & dbName & "."
        Case Else
            ' Visual Basic's default error message.
            errorMsg = Error$
    End Select

    ' Display the error message.
    MsgBox errorMsg, vbExclamation

    ' Return false to indicate that the name being checked was not legal.
    LegalName = False

Exit Function

End Function

Private Sub cmdRemoveField_Click()

    ' If the user has selected a field, remove it from the list.
    ' Otherwise, just ignore the click.
    If lstFields.ListIndex > -1 Then lstFields.RemoveItem lstFields.ListIndex

End Sub

Private Sub cmdCreateTable_Click()
    Dim sql As String
    Dim fieldList As String
    Dim i As Integer
    Dim db As DATABASE
    Dim dbName As String

    On Error GoTo CreateTableError

    Screen.MousePointer = 11

    ' Make sure the name entered in txtTableName meets all the
    ' requirements for a legal table name.
    If LegalName(TABLENAME) Then

        ' Make sure the user has created at least one field.
        If lstFields.ListCount > 0 Then

            ' Build the list of fields that will be used as an argument in
            ' the CREATE TABLE statement.
            fieldList = " (" & lstFields.List(0)
            For i = 1 To lstFields.ListCount - 1
                fieldList = fieldList & ", " & lstFields.List(i)
            Next i
            fieldList = fieldList & ") "

            ' Build the SQL statement.
            sql = "CREATE TABLE [" & txtTableName & "]" & fieldList

  ' Get the database name and open the database.
    dbName = BiblioPath()       ' BiblioPath is a function in READINI.BAS
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)

    db.Execute (sql)

            Screen.MousePointer = 0
            MsgBox "Table created successfully."

            ' Initialize txtTableName and the fields list for the next table.
            txtTableName = ""
            lstFields.Clear

        Else

            MsgBox "You must define at least one field.", vbExclamation

        End If

    End If

Exit Sub
CreateTableError:
    Screen.MousePointer = 0
    MsgBox Error$, vbExclamation
Exit Sub
End Sub

Private Sub cmdClose_Click()
    Dim errorMsg As String

    ' If the user has entered a partial table definition, make sure that the
    ' user wants to abandon it. If so, end the program.
    If txtTableName <> "" Or lstFields.ListCount > 0 Then
        errorMsg = "Do you want to abandon operations on the current table?"
        If MsgBox(errorMsg, vbQuestion + vbYesNo + vbDefaultButton2) = vbYes _
            Then End

    Else

        ' No partial table definition, so just end the program
        End

    End If

End Sub